home *** CD-ROM | disk | FTP | other *** search
/ Shareware Grab Bag / Shareware Grab Bag.iso / 050 / tpasextr.arc / DEMO.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1986-11-22  |  16.4 KB  |  486 lines
  1. program demo;
  2.  
  3. {----------------------------------------------------------}
  4. {-                                                        -}
  5. {- Global type delcarations required for the procedures:  -}
  6. {-                                                        -}
  7. {-                 ColorMsg                               -}
  8. {-                 WaitMsg                                -}
  9. {-                 WriteSt                                -}
  10. {-                 WriteStLn                              -}
  11. {-                                                        -}
  12. {----------------------------------------------------------}
  13.  
  14. Type
  15.    Str255 = String[255];
  16.    Str2   = String[2];
  17.    TSet   = Set of 0..255;
  18.    TMenu  = ^TM;
  19.    TM     = Record
  20.                Nxt,Prev : TMenu;
  21.                XY       : Array[1..8,1..8] Of Byte;
  22.                Items    : String[255];
  23.                Desc     : Array[1..8] Of String[80];
  24.             End;
  25.  
  26. {----------------------------------------------------------}
  27. {- Global type and variable declarations for demo program -}
  28. {----------------------------------------------------------}
  29.  
  30. Var
  31.    Done  : Boolean;
  32.    Ch    : Char;
  33.  
  34. {----------------------------------------------------------}
  35. {-                                                        -}
  36. {- External procedure declarations                        -}
  37. {-                                                        -}
  38. {----------------------------------------------------------}
  39.  
  40. Procedure BoarderColor(Color : Integer);                    External 'V1.ENH';
  41. Procedure ClrWin;                                           External 'V2.ENH';
  42. Procedure ColorMsg(X,Y,Color : Integer; Message : Str255);  External 'V3.ENH';
  43. Procedure FillCol(X,Y,Num : Integer; Ch : Char);            External 'V4.ENH';
  44. Procedure FillColAttrib(X,Y,Num,Color : Integer);           External 'V5.ENH';
  45. Procedure FillRow(X,Y,Num : Integer; Ch : Char);            External 'V6.ENH';
  46. Procedure FillRowAttrib(X,Y,Num,Color : Integer);           External 'V7.ENH';
  47. Procedure FrameWin(UL,UR,LL,LR,Hor,Ver : Char);             External 'V8.ENH';
  48. Procedure GetScrn(X,Y,NumChars : Integer; Var ChArray);     External 'V10.ENH';
  49. Procedure GotoXYAbs(X,Y : Integer);                         External 'V12.ENH';
  50. Procedure InitVideo(Mode : Integer);                        External 'V13.ENH';
  51. Procedure PutScrn(X,Y,NumChars : Integer; Var ChArray);     External 'V14.ENH';
  52. Procedure RvsVideo;                                         External 'V15.ENH';
  53. Procedure ScrollDn(Lines,Color,X1,Y1,X2,Y2 : Integer);      External 'V16.ENH';
  54. Procedure ScrollLeft(X1,Y1,X2,Y2,Cols,Color : Integer);  External 'V17.ENH';
  55. Procedure ScrollUp(Lines,Color,X1,Y1,X2,Y2 : Integer);      External 'V18.ENH';
  56. Procedure ScrollRight(Columns,Color,X1,Y1,X2,Y2 : Integer); External 'V19.ENH';
  57. Procedure SetCursorSize(StartLine,EndLine : Integer);       External 'V20.ENH';
  58. Procedure WaitMsg(X,Y   : Integer;     Msg : Str255;
  59.                   TESet : TSet;    Var TE  : Integer);      External 'V21.ENH';
  60. Procedure WriteSt(St : Str255);                             External 'V24.ENH';
  61. Procedure WriteStLn(St : Str255);                           External 'V25.ENH';
  62. Procedure EditSt(X,StY,SpY,Len,CM : Integer;
  63.                       VCSet,TCSet : TSet;
  64.                   Var TE          : Integer;
  65.                   Var St                    );              External 'V26.ENH';
  66.  
  67. Function GetCursorSize : Integer;                           External 'V9.ENH';
  68. Function GetVideoMode  : Integer;                           External 'V11.ENH';
  69. Function WhereXAbs     : Integer;                           External 'V22.ENH';
  70. Function WhereYAbs     : Integer;                           External 'V23.ENH';
  71.  
  72.  
  73. Procedure DoBoarderColor;
  74. Var
  75.    Color : Integer;
  76. Begin
  77.    Repeat
  78.       ClrScr;
  79.       WriteStLn('Enter a value from 0-15 to see a boarder color');
  80.       WriteSt('Enter a value >15 to quit ');
  81.       Readln(Color);
  82.       BoarderColor(Color);
  83.    Until (Color < 0) Or (Color > 15);
  84.    BoarderColor(0);
  85. End;
  86.  
  87. Procedure DoColorMsg;
  88. Var
  89.    i : Integer;
  90. Begin
  91.    For i := 1 To 20 Do
  92.       ColorMsg(10,i,i,'This is a message using color');
  93.    ColorMsg(10,24,7,'Press [ENTER] to continue');
  94.    Readln;
  95. End;
  96.  
  97. Procedure DoFillCol;
  98. Var
  99.    i,j,k : Integer;
  100. Begin
  101.    j := 1;
  102.    repeat
  103.       ColorMsg(41,4,48,'                                    ');
  104.       ColorMsg(41,5,48,'  Enter a value (1-40) to display   ');
  105.       ColorMsg(41,6,48,'  a column of characters.           ');
  106.       ColorMsg(41,7,48,'                                    ');
  107.       ColorMsg(41,8,48,'  Any value not in range will exit  ');
  108.       ColorMsg(41,9,48,'                                    ');
  109.       GotoXYAbs(41,10);
  110.       ClrEol;
  111.       Readln(i);
  112.       FillCol(i,1,25,Chr(64+j));
  113.       If (i > 0) And (i < 41) Then Begin
  114.             ColorMsg(41,4,48,'                                    ');
  115.             ColorMsg(41,5,48,'  Enter a value (0-255) to display  ');
  116.             ColorMsg(41,6,48,'  the color for the column of chars.');
  117.             ColorMsg(41,7,48,'                                    ');
  118.             ColorMsg(41,8,48,'  Any value not in range will exit  ');
  119.             ColorMsg(41,9,48,'                                    ');
  120.             GotoXYAbs(41,10);
  121.             ClrEol;
  122.             Readln(k);
  123.             FillColAttrib(i,1,25,k);
  124.             j := j + 1;
  125.          End
  126.       Else
  127.          j := 26;
  128.    Until (i < 0) Or (i > 40) Or (j > 25) Or (k < 0) Or (k > 255);
  129. End;
  130.  
  131. Procedure DoFillRow;
  132. Var
  133.    i,j,k : Integer;
  134. Begin
  135.    j := 1;
  136.    repeat
  137.       ColorMsg(41,18,48,'                                    ');
  138.       ColorMsg(41,19,48,'  Enter a value (1-25) to display   ');
  139.       ColorMsg(41,20,48,'  a row of characters.              ');
  140.       ColorMsg(41,21,48,'                                    ');
  141.       ColorMsg(41,22,48,'  Any value not in range will exit  ');
  142.       ColorMsg(41,23,48,'                                    ');
  143.       GotoXYAbs(41,24);
  144.       ClrEol;
  145.       Readln(i);
  146.       FillRow(1,i,80,Chr(64+j));
  147.       If (i > 0) And (i < 26) Then Begin
  148.             ColorMsg(41,18,48,'                                    ');
  149.             ColorMsg(41,19,48,'  Enter a value (0-255) to display  ');
  150.             ColorMsg(41,20,48,'  the color for the row of chars.   ');
  151.             ColorMsg(41,21,48,'                                    ');
  152.             ColorMsg(41,22,48,'  Any value not in range will exit  ');
  153.             ColorMsg(41,23,48,'                                    ');
  154.             GotoXYAbs(41,24);
  155.             ClrEol;
  156.             Readln(k);
  157.             FillRowAttrib(1,i,80,k);
  158.             j := j + 1;
  159.          End
  160.       Else
  161.          j := 26;
  162.    Until (i < 0) Or (i > 25) Or (j > 25) Or (k < 0) Or (k > 255);
  163. End;
  164.  
  165. Procedure DoFrameWin;
  166. Var
  167.    i,j : Integer;
  168. Begin
  169.    For i := 1 To 10 Do Begin
  170.       Window(i,i,80-i,25-i);
  171.       FrameWin('┌','┐','└','┘','─','│');
  172.       ClrWin;
  173.       GotoXY(1,1);
  174.       For j := 1 to 20 do
  175.          Writeln('This is window ',i:1);
  176.       Writeln('Press [ENTER] to continue... ');
  177.       Readln;
  178.    End;
  179.    Window(1,1,80,25);
  180. End;
  181.  
  182. Procedure DoCursorSize;
  183. Var
  184.    i    : Integer;
  185.    Done : Boolean;
  186. Begin
  187.    Done := False;
  188.    Repeat
  189.       ClrScr;
  190.       WriteStLn('This routine demonstrates 3 Cursor sizes');
  191.       WriteStLn('for use with the color/graphic adapter');
  192.       WriteStLn(' ');
  193.       WriteStLn('    0 - Normal');
  194.       WriteStLn('    1 - Large');
  195.       WriteStLn('    2 - Hidden');
  196.       WriteStLn(' ');
  197.       WriteStLn('Enter a value (0-3) for the size cursor you want ');
  198.       WriteSt('Enter any value outside range to exit ');
  199.       Readln(i);
  200.       Case GetVideoMode Of
  201.          7 : Case i Of
  202.                 0 : SetCursorSize(13,12);
  203.                 1 : SetCursorSize(13,0);
  204.                 2 : SetCursorSize(32,32);
  205.              Else
  206.                 Done := True;
  207.              End;
  208.       Else
  209.          Case i Of
  210.             0 : SetCursorSize(7,6);
  211.             1 : SetCursorSize(7,0);
  212.             2 : SetCursorSize(32,32);
  213.          Else
  214.             Done := True;
  215.          End;
  216.       End;
  217.       WriteStLn(' ');
  218.       WriteStLn('The new cursor scan lines are:');
  219.       WriteStLn(' ');
  220.       WriteStLn('  Start Scan       Stop Scan');
  221.       WriteStLn('  ----------       ---------');
  222.       i := GetCursorSize;
  223.       Writeln(Hi(i):7,Lo(i):17);
  224.       WriteStLn(' ');
  225.       WriteStLn('Press [ENTER] to continue... ');
  226.       Readln;
  227.    Until Done;
  228. End;
  229.  
  230. Procedure DoScrn;
  231. Var
  232.    CA2 : Array[1..640] Of Char;
  233.    TE  : Integer;
  234. Begin
  235.    WriteStLn('This is line 1 of the screen.  This line and the next 3 lines');
  236.    WriteStLn('will be read from the screen and placed on lines 15-18');
  237.    WriteStLn('All you will have to do is press the [ENTER] key to continue');
  238.    WriteStLn('thru this procedure.');
  239.    Readln;
  240.    GetScrn(1,1,320,CA2);
  241.    WaitMsg(1,6,
  242.           'The screen has been read.  Press [ENTER] to continue... ',[13],TE);
  243.    PutScrn(1,15,320,CA2);
  244.    WaitMsg(1,7,'Press [ENTER] to exit this procedure',[13],TE);
  245. End;
  246.  
  247. Procedure DoRvsVideo;
  248. Var
  249.    TE : Integer;
  250. Begin
  251.    WriteLn('This is how text is displayed before RvsVideo');
  252.    WaitMsg(1,5,'Press [ESC] to continue...',[1],TE);
  253.    RvsVideo;
  254.    WriteLn('This is how text is displayed after RvsVideo');
  255.    WaitMsg(1,5,'Press [ESC] to continue...',[1],TE);
  256.    RvsVideo;
  257. End;
  258.  
  259. Procedure DoScroll;
  260. Var
  261.    i  : Integer;
  262.    Ch : Char;
  263. Begin
  264.    ClrScr;
  265.    WriteStLn(' We will be scrolling the contents of window');
  266.    WriteStLn(' either one column or row at a time');
  267.    WriteStLn(' ');
  268.    WriteStLn(' L - Scroll Left one column');
  269.    WriteStLn(' R - Scroll Right one column');
  270.    WriteStLn(' U - Scroll Up one row');
  271.    WriteStLn(' D - Scroll Down one row');
  272.    WriteStLn(' Q - Quit and return to menu');
  273.    WriteStLn(' Press key for desired action');
  274.    Window(48,1,80,25);
  275.    FrameWin('┌','┐','└','┘','─','│');
  276.    For i := 49 To 79 Do
  277.       FillCol(i,2,23,Chr(i+16));
  278.    Repeat
  279.       Read(Kbd,Ch);
  280.       Ch := UpCase(Ch);
  281.       Case Ch Of
  282.          'L' : ScrollLeft (49,2,79,24,1,48);
  283.          'R' : ScrollRight(49,2,79,24,1,48);
  284.          'U' : ScrollUp   (49,2,79,24,1,7);
  285.          'D' : ScrollDn   (49,2,79,24,1,7);
  286.       End;
  287.    Until Ch = 'Q';
  288.    Window(1,1,80,25);
  289. End;
  290.  
  291. Procedure DoCursorPos;
  292. Var
  293.    x,y : Integer;
  294. Begin
  295.    Window(54,9,80,14);
  296.    FrameWin('┌','┐','└','┘','─','│');
  297.    Repeat
  298.       ClrWin;
  299.       ColorMsg(55,10,6,'                      ');
  300.       ColorMsg(55,11,6,'Enter Column (1-40)   ');
  301.       ColorMsg(55,12,6,'                      ');
  302.       GotoXYAbs(75,11);
  303.       Readln(x);
  304.       ColorMsg(55,12,11,'Enter Row (1-25)      ');
  305.       GotoXYAbs(72,12);
  306.       Readln(y);
  307.       GotoXYAbs(x,y);
  308.       y := WhereXAbs;
  309.       x := WhereYAbs;
  310.       ClrWin;
  311.       ColorMsg(55,11,1,'Press [ENTER] to continue');
  312.       Readln;
  313.       ClrScr;
  314.       GotoXY(1,1);
  315.       Writeln('The absolute column = ',y:1);
  316.       Writeln('The absolure row    = ',x:1);
  317.       ColorMsg(55,13,1,'Press [ENTER] to continue');
  318.       GotoXYAbs(y,x);
  319.       Readln;
  320.    Until (x > 40) Or (x < 1) Or (y > 25) Or (y < 1);
  321.    Window(1,1,80,25);
  322. End;
  323.  
  324. Procedure DoVideoModes;
  325. Var
  326.    i,j : Integer;
  327.    TE  : Integer;
  328. Begin
  329.    i := GetVideoMode;
  330.    Gotoxy(5,10);
  331.    Case i of
  332.       0..6 : WriteStln('You have a color/graphics adapter card installed');
  333.       7    : WriteStln('You use a monochrome monitor on your system');
  334.    Else
  335.       WriteStln('Enhance graphics adapter card installed?');
  336.    End;
  337.    Writeln;
  338.    WriteStLn('Press [ENTER] to continue...');
  339.    Readln;
  340.    Writeln;
  341.    WriteStln('Enter a value (0-7) for initializing a video mode');
  342.    Readln(j);
  343.    InitVideo(j);
  344.    j := GetVideoMode;
  345.    InitVideo(i);
  346.    WriteSt('I initialized the video mode to number ');
  347.    Writeln(j:1);
  348.    WriteStln('I also returned you to the mode you were in before');
  349.    WriteStln('I printed out the above statement.');
  350.    WriteStln(' ');
  351.    WaitMsg(1,25,'Press [ESC] to continue...',[1],TE);
  352. End;
  353.  
  354. Procedure DoEditSt;
  355. Var
  356.    St    : Array[1..6] Of Str255;
  357.    St1,St2   : Str255;
  358.    TE    : Integer;
  359.    TCS,
  360.    TeCS,
  361.    EdCS,
  362.    VaCS  : TSet;
  363.    i,CCM,
  364.    TLen  : Integer;
  365.    Info  : Array[1..5,1..6] Of Byte;
  366.    Title : Array[1..6] Of String[10];
  367. Begin
  368.    TeCS := [13,60,71..81];
  369.    TCS  := TeCS;
  370.    EdCS := [1,13,60,72,80];
  371.    VaCS := [32..255];    { ,65..90,97..122]; }
  372.    CCM  := 1;
  373.    FillChar(St,SizeOf(St),0);
  374.    FillChar(St1,SizeOf(St1),0);
  375.    FillChar(St2,SizeOf(St2),0);
  376.  
  377.    { Row           Start Col       Stop Col        Len           Case Mode }
  378.    {------------  -------------  -------------  -------------  ----------- }
  379.    Info[1,1]:=10; Info[2,1]:=10; Info[3,1]:=20; Info[4,1]:=25; Info[5,1]:=1;
  380.    Info[1,2]:=12; Info[2,2]:=10; Info[3,2]:=25; Info[4,2]:=30; Info[5,2]:=1;
  381.    Info[1,3]:=14; Info[2,3]:=10; Info[3,3]:=35; Info[4,3]:=15; Info[5,3]:=1;
  382.    Info[1,4]:=10; Info[2,4]:=50; Info[3,4]:=51; Info[4,4]:= 2; Info[5,4]:=2;
  383.    Info[1,5]:=12; Info[2,5]:=50; Info[3,5]:=55; Info[4,5]:= 5; Info[5,5]:=1;
  384.    Info[1,6]:=14; Info[2,6]:=50; Info[3,6]:=75; Info[4,6]:=30; Info[5,6]:=3;
  385.    Title[1] := 'Name   :';   Title[2] := 'Address:';
  386.    Title[3] := 'City   :';   Title[4] := 'State  :';
  387.    Title[5] := 'Zip    :';   Title[6] := 'Remarks:';
  388.    ClrScr;
  389.    Gotoxy(1,20);
  390.    WriteStLn('This is a simple editting routine.  ');
  391.    WriteStLn('Use the F2 key to enable editting keys');
  392.    WriteStLn('Enter xxxxx to quit');
  393.    ColorMsg(1,10,7,'Name   :');
  394.    ColorMsg(1,12,7,'Address:');
  395.    ColorMsg(1,14,7,'City   :');
  396.    ColorMsg(40,10,7,'State   :');
  397.    ColorMsg(40,12,7,'Zip     :');
  398.    ColorMsg(40,14,7,'Remarks :');
  399.    FillRow(1,3,80,'-');
  400.    i := 1;
  401.    ColorMsg(75,1,48,'READY');
  402.    Repeat
  403.       If TE <> 60 Then
  404.          FillChar(St1,SizeOf(St1),0);
  405.       FillRow(1,1,73,' ');
  406.       FillRow(1,2,80,' ');
  407.       St2 := Title[i] + ' ' + St[i];
  408.       If Length(St2) > 73 Then
  409.          St2[0] := chr(73);
  410.       ColorMsg(1,1,7,St2);
  411.       FillRowAttrib(Info[2,i],Info[1,i],Info[3,i]-Info[2,i]+1,48);
  412.       EditSt(2,1,Info[4,i]+1,Info[4,i],Info[5,i],VaCS,TCS,TE,St1);
  413.       FillRowAttrib(Info[2,i],Info[1,i],Info[3,i]-Info[2,i]+1,7);
  414.       ColorMsg(75,1,48,'READY');
  415.       TCS := TeCS;
  416.       If (St1 <> '') And (TE <> 1) Then
  417.          St[i] := St1;
  418.       TLen := Ord(St[i][0]);
  419.       If Ord(St[i][0]) > Info[3,i]-Info[2,i]+1 Then
  420.          St[i][0] := Chr(Info[3,i] - Info[2,i] + 1);
  421.       FillRow(Info[2,i],Info[1,i],Info[3,i]-Info[2,i]+1,' ');
  422.       ColorMsg(Info[2,i],Info[1,i],7,St[i]);
  423.       St[i][0] := Chr(TLen);
  424.       Case TE Of
  425.          71,73 : i := 1;
  426.          72    : If i > 1 Then i := i - 1;
  427.          75    : If i > 3 Then i := i - 3;
  428.          77    : If i < 4 Then i := i + 3;
  429.          79    : i := 6;
  430.          13,80 : If i < 6 Then i := i + 1;
  431.          60    : Begin
  432.                     TCS := EdCS;
  433.                     St1 := St[i];
  434.                     ColorMsg(75,1,48,'EDIT ');
  435.                  End;
  436.       End;
  437.    Until (St1 = 'XXXXX') Or (St1 = 'xxxxx');
  438. End;
  439.  
  440.  
  441. {--------------  Main Program ---------------------------}
  442.  
  443. Begin
  444.    Done := False;
  445.    TextColor(7);
  446.    Repeat
  447.       ClrScr;
  448.       WriteStLn('   This menu is displayed using WriteStLn');
  449.       WriteStLn(' ');
  450.       WriteStLn('   Press a letter for the procedures to demonstrate');
  451.       WriteStLn(' ');
  452.       WriteStLn('      A.  BoarderColor, WriteSt');
  453.       WriteStLn('      B.  FillCol, FillColAttrib, ColorMsg');
  454.       WriteStLn('      C.  FillRow, FillRowAttrib, ColorMsg');
  455.       WriteStLn('      D.  FrameWin, ClrWin');
  456.       WriteStLn('      E.  GetCursorSize, SetCursorSize');
  457.       WriteStLn('      F.  GetScrn, PutScrn');
  458.       WriteStLn('      G.  RvsVideo');
  459.       WriteStLn('      H.  ScrollLeft, ScrollRight, ScrollUp, ScrollDn');
  460.       WriteStLn('      I.  GotoXYAbs, WhereXAbs, WhereYAbs');
  461.       WriteStLn('      J.  InitVideo, GetVideoMode');
  462.       WriteStLn('      K.  EditSt');
  463.       WriteStLn(' ');
  464.       WriteStLn('      M.  Quit this demo');
  465.       WriteStLn(' ');
  466.       Read(Kbd,Ch);
  467.       Ch := UpCase(Ch);
  468.       ClrScr;
  469.       Case Ch Of
  470.          'A' : DoBoarderColor;
  471.          'B' : DoFillCol;
  472.          'C' : DoFillRow;
  473.          'D' : DoFrameWin;
  474.          'E' : DoCursorSize;
  475.          'F' : DoScrn;
  476.          'G' : DoRvsVideo;
  477.          'H' : DoScroll;
  478.          'I' : DoCursorPos;
  479.          'J' : DoVideoModes;
  480.          'K' : DoEditSt;
  481.          'M' : Done := True;
  482.       End;
  483.    Until Done;
  484.    ClrScr;
  485. End.
  486.